;;; ==================================================================
;;;
;;;             	UTILITY FUNCTIONS
;;; 			-----------------
;;; 
;;; 			  Masaru Tomita
;;; 		  Center for Machine Translation
;;;		    Carnegie-Mellon University
;;; 
;;; ==================================================================
	
;;;   util.lisp consists of the following functions:
;;;
;;;     MAP-DOLIST, APPEND-DOLIST, OR-DOLIST, AND-DOLIST
;;;     COMPILE-FILE!, READ-FILE-LIST, WRITE-FILE-LIST, FILE-NEWER-THAN
;;; 	LOAD-NEWER-FILE, APPEND-STR, APPEND-FILES

;;; __________________________________________________________________
;;; 
;;;   DOLIST macros
;;; __________________________________________________________________
;;; 

;;; 
;;;   MAP-DOLIST is like DOLIST, except it returns a list of all results.
;;; 
(defmacro map-dolist (varlist body)
 (let ((map-result (gensym)))
 `(let ((,map-result nil))
    (dolist ,varlist (push ,body ,map-result))
     (nreverse ,map-result))))

;;; 
;;;   APPEND-DOLIST is like DOLIST, except it returns an appended list of
;;;       all results.
;;; 
(defmacro append-dolist (varlist body)
 (let ((append-result (gensym)))
  `(let ((,append-result nil))
    (dolist ,varlist (setq ,append-result (append ,body ,append-result)))
    ,append-result)))

;;; 
;;;    OR-DOLIST is like DOLIST, except that as soon as one of its
;;;        element returns a non-nil value, quit DOLIST and return
;;; 	   the value.  If all return nil, then return nil.
;;; 
(defmacro or-dolist (varlist body)
 (let ((result (gensym)))
  `(let ((,result nil))
    (dolist ,varlist
	 (setq ,result ,body)
	 (if ,result (return ,result))))))

;;; 
;;;    AND-DOLIST is like DOLIST, except that as soon as one of its
;;;        element returns nil value, quit DOLIST and return nil.
;;; 	   If all return non-nil values, then return the last value.
;;; 
(defmacro and-dolist (varlist body)
 (let ((result (gensym)))
  `(let ((,result nil))
    (dolist ,varlist
	 (setq ,result ,body)
	 (if (null ,result) (return nil)))
    ,result)))

;;; ___________________________________________________________________
;;; 
;;;   File I/O Functions
;;; ___________________________________________________________________
;;; 

;;; 
;;; COMPILE-FILE compiles files and then load it.
;;; 
(defun compile-file! (&rest file-names)
  (dolist (file-name file-names)
    (compile-file file-name)
    (load file-name)))

;;; 
;;; READ-FILE-LIST takes a file name and returns contents of the file
;;; as a list.
;;; 
(defun read-file-list (file)
 (let ((obj-list nil))
  (format t " - Reading ~A~%" file)
  (with-open-file (ifile file :direction :input)
    (do ((obj (read ifile nil '%eof%)(read ifile nil '%eof%)))
	((eq obj '%eof%))
      (push obj obj-list)))
  (setq obj-list (nreverse obj-list))
  (format t " - ~A read~%" file)
  obj-list))

;;; 
;;; WRITE-FILE-LIST takes a list of objects and a file name as its
;;; arguments and writes each element of the list to the file.
;;; 
(defun write-file-list (obj-list file &key (if-exists :new-version))
  (let ((save-pretty-flag *print-pretty*))
   (setq *print-pretty* nil)
   (format t " - Writing File ~A~%" file)
   (with-open-file (ofile file :direction :output :if-exists if-exists)
     (princ ";;;;; -*- mode: lisp; syntax: common-lisp; package: cl-user; base: 10 -*- ;;;;" ofile)
     (terpri ofile)
     (dolist (obj obj-list)
	(prin1 obj ofile)(terpri ofile)))
   (format t " - File ~A written~%" file)
   (setq *print-pretty* save-pretty-flag)))

;;;  If file1 is newer (later) than file2, return t, otherwise nil.
;;;  If both don't exist, return nil.
;;;  If file2 doesn't exist, return t.
;;;  If file1 doesn't exist, return nil.
;;;
(defun file-newer-than (file1 file2)
  (let ((file1-date (and (probe-file file1)(file-write-date file1)))
	(file2-date (and (probe-file file2)(file-write-date file2))))
    (cond ((null (or file1-date file2-date)) nil)
	  ((null file2-date) t)
	  ((null file1-date) nil)
	  (t (> file1-date file2-date)))))

;;; 
;;;  LOAD-NEWER-FILE loads whichever of file1 and file2 is newer.
;;; 
(defun load-newer-file (file1 file2)
  (cond ((file-newer-than file1 file2)
	 (format t " - Loading ~A~%" file1)
	 (load file1))
	(t
	 (format t " - Loading ~A~%" file2)
   	 (load file2))))
;;; 
;;;  (append-str "masaru" "tomita") ==> "masarutomita"
;;;
(defun append-str (str1 str2 &optional (str3 "")(str4 ""))
  (concatenate 'string str1 str2 str3 str4))

;;;    (explode-string "tomita") ==> (t o m i t a)
;;;
(defun explode-string (instring)
  (explode-input-string (remove #\  instring)))

(defun explode-input-string (string)
  (map 'list #'(lambda (char) (intern (string (char-upcase char)))) string))

;;;    (root-symbol "get rid of") ==> GET-RID-OF
;;;
(defun root-symbol (instring)
  (intern (string-upcase (substitute #\- #\space instring))))

;;; 
;;;  Append files a b c into d.
;;;  (append-files '("a" "b" "c") "d")
;;; 
(defun append-files (file-name-list dest-file)
  (dolist (file-name  file-name-list)
	(write-file-list (read-file-list file-name)
			 dest-file :if-exists :append)))
